unit UMonoRTTIInv;

interface
uses Classes, SysUtils, Variants, StrUtils, RTTI, TypInfo, UMonoIntf, UMono,
  dialogs, UScriptClass, Generics.Collections;

function DelphiRTTIInvoke(aProxy: PMonoObject; aInstance: pointer; aTypeName: PMonoString; aMethodName: PMonoString; aParams: PMonoArray): PMonoObject; cdecl;

type
  TMonoDelphiRTTI = class
  private
    class var FContext: TRttiContext;
  protected
    class constructor Create;
    class destructor Destroy;
  public
    class property RttiContext: TRttiContext read FContext;
  public
    class function IsMonoTypeCompatible(mType:TMonoTypeEnum; mByRef: boolean; dType: TRttiType): boolean;
    class function ValueFromMonoObject(mType: TMonoParamDef;
         mValue: PMonoObject; dType: TRttiType): TValue;
    class function ValueToMonoObject(aValue: TValue; mType:TMonoParamDef; dType: TRttiType; aDomain: PMonoDomain = nil): PMonoObject;
    class function InvokeObjMethod(aProxy: PMonoObject; aObject: TObject; aMethodName: string; aMonoParams: TList; aMonoMethInfo: TMonoMethodInfo): pointer;
  end;

type
  TArrayTValue = array of TValue;
  Tint32Array = array of integer;

implementation

function DelphiRTTIInvoke(aProxy: PMonoObject; aInstance: pointer; aTypeName: PMonoString; aMethodName: PMonoString; aParams: PMonoArray): PMonoObject; cdecl;
var
  lMonoParams: TList;
  lParamCount, i: integer;
  lobj: PMonoObject;
  lMethodName, lMonoClassName, lNameSpace: string;
  lMonoClass: PMonoClass;
  lMonoMethod: PMonoMethod;
  lMonoMethInfo: TMonoMethodInfo;
begin
  // trasformare in TList l'array di PMonoObject
  lMonoParams := TList.Create;
  try
    lParamCount := mono_array_length(aParams);
    for i := 0 to lParamCount - 1 do
    begin
      GetArrayValue(aParams, sizeof(PMonoObject), i, lobj);
      lMonoParams.Add(lobj);
    end;
    lMethodName := TMonoConvert.MonoStrToString(aMethodName);
    lMonoClassName := TMonoConvert.MonoStrToString(aTypeName);
    i := pos('.', lMonoClassName);
    if i > 0 then
    begin
      lNameSpace := Copy(lMonoClassName, 1, i-1);
      Delete(lMonoClassName, 1, i);
    end;
    lMonoClass := MonoJit.FindMonoClass(lNameSpace, lMonoClassName);
    lMonoMethod := MonoJit.FindMonoMethod(lMonoClass, lMethodName, '', false);
    lMonoMethInfo := MonoJit.GetMonoMethodInfo(lMonoMethod);

    result := TMonoDelphiRTTI.InvokeObjMethod(aProxy, TObject(aInstance), lMethodName, lMonoParams, lMonoMethInfo);

    for i := 0 to lMonoMethInfo.paramCount - 1 do
    begin
      if lMonoMethInfo.params[i].ByRef then
      begin
        lObj := PMonoObject(lMonoParams[i]);
        SetArrayRef(aParams, i, lobj);
      end;
    end;

  finally
    lMonoParams.Free;
  end;
end;

{ TMonoDelphiRTTI }

class constructor TMonoDelphiRTTI.Create;
begin
  FContext := TRttiContext.Create;
end;

class destructor TMonoDelphiRTTI.Destroy;
begin
  FContext.Free;
end;

class function TMonoDelphiRTTI.InvokeObjMethod(aProxy: PMonoObject; aObject: TObject; aMethodName: string;
  aMonoParams: TList; aMonoMethInfo: TMonoMethodInfo): pointer;
var
  lRootType: TRttiType;
  cls: TRttiInstanceType;
  meth : TRttiMethod;
  prop : TRttiProperty;
  param : TRttiParameter;
  sPropName: string;
  params : TArray<TValue>;
  resultValue : TValue;
  lparamOK: boolean;
  i: integer;
  lhlpCls: TClass;
  o: TObject;
  Method: TMethod;
  lDomain: PMonoDomain;
begin
  result := nil;
  lDomain := mono_object_get_domain(aProxy);
  lRootType := RttiContext.GetType(aObject.ClassType);
  if lRootType is TRttiInstanceType then
  begin
    cls := TRttiInstanceType(lRootType);
    for meth in cls.GetMethods do
    begin
      if SameText(meth.Name, aMethodName) then
      begin
        lparamOK := true;
        // test overload
        i := 0;
        for param in meth.GetParameters do
        begin
          if i >= aMonoParams.Count then
          begin
            lparamOK := false;
            break;
          end;

          if not( IsMonoTypeCompatible(aMonoMethInfo.params[i].ParamType, aMonoMethInfo.params[i].ByRef, param.ParamType)) then
          begin
            lparamOK := false;
            break;
          end;
          inc(i);
        end;

        if lparamOK then
        begin
          SetLength(params, aMonoParams.Count);
          i := 0;
          for param in meth.GetParameters do
          begin
            params[i] := ValueFromMonoObject(aMonoMethInfo.params[i], PMonoObject(aMonoParams[i]), param.ParamType);
            inc(i);
          end;

          resultValue := meth.Invoke(aObject, params);
          if meth.ReturnType = nil then
            result := nil
          else
            result := ValueToMonoObject(resultValue, aMonoMethInfo.result, meth.ReturnType, lDomain);
          // args by ref
          for i := 0 to aMonoMethInfo.paramCount - 1 do
          begin
            if aMonoMethInfo.params[i].ByRef then
            begin
              aMonoParams[i] := ValueToMonoObject(params[i], aMonoMethInfo.params[i], meth.GetParameters[i].ParamType, lDomain);
            end;
          end;

          exit;
        end;
      end;
    end;

    if StartsText('get_', aMethodName) then
      sPropName := copy(aMethodName, 5, length(aMethodName))
    else if StartsText('set_', aMethodName) then
      sPropName := copy(aMethodName, 5, length(aMethodName))
    else if StartsText('add_', aMethodName) then
      sPropName := copy(aMethodName, 5, length(aMethodName))
    else if StartsText('remove_', aMethodName) then
      sPropName := copy(aMethodName, 8, length(aMethodName))
    else
      sPropName := '';

    if sPropName <> '' then
      for prop in cls.GetProperties do
      begin
        if SameText(prop.Name, sPropName) then
        begin
          if StartsText('get_', aMethodName) then
          begin
            resultValue := prop.GetValue(aObject);
            result := ValueToMonoObject(resultValue, aMonoMethInfo.result, prop.PropertyType, lDomain);
            exit;
          end
          else if StartsText('set_', aMethodName) then
          begin
            resultValue := ValueFromMonoObject(aMonoMethInfo.params[0], PMonoObject(aMonoParams[0]), prop.PropertyType);
            prop.SetValue(aObject, resultValue);
            exit;
          end
          else if StartsText('add_', aMethodName) then
          begin
            if aObject is TComponent then
            begin
              o := TComponent(aObject).FindComponent('MonoEvent');
              if o = nil then
              begin
                o := TMonoEventComp.Create(TComponent(aObject));
                TComponent(o).Name := 'MonoEvent';
              end;
              resultValue := prop.GetValue(aObject);
              if TMonoEventComp(o).add_Delegate(sPropName, aMonoMethInfo.signature, PMonoObject(aMonoParams[0]), resultValue) then
                prop.SetValue(aObject, resultValue);
            end;

            exit;
          end
          else if StartsText('remove_', aMethodName) then
          begin
            if aObject is TComponent then
            begin
              o := TComponent(aObject).FindComponent('MonoEvent');
              if o = nil then
                exit;
              resultValue := prop.GetValue(aObject);
              if TMonoEventComp(o).remove_delegate(sPropName, PMonoObject(aMonoParams[0]), resultValue) then
              begin
                prop.SetValue(aObject, resultValue);
                //resultValue.ExtractRawData(@Method);
                //Method.Code := nil;
                //Method.Data := nil;
                //if prop.Visibility = mvPublished then
                //  SetMethodProp(aObject, sPropName, Method);
              end;
            end;
            exit;
          end;
        end;
      end;

    // helper class
    lhlpCls := ScriptHelper(aObject.ClassType);
    if lhlpCls <> nil then
    begin
      lRootType := RttiContext.GetType(lhlpCls);

      cls := TRttiInstanceType(lRootType);
      for meth in cls.GetMethods do
      begin
        if SameText(meth.Name, aMethodName) then
        begin
          lparamOK := true;
          // test overload parametri
          i := 0;
          for param in meth.GetParameters do
          begin
            if i >= (aMonoParams.Count+1) then
            begin
              lparamOK := false;
              break;
            end;

            if i > 0 then
              if not( IsMonoTypeCompatible(aMonoMethInfo.params[i-1].ParamType, aMonoMethInfo.params[i-1].ByRef, param.ParamType)) then
              begin
                lparamOK := false;
                break;
              end;
            inc(i);
          end;

          if lparamOK then
          begin
            SetLength(params, aMonoParams.Count+1);
            i := 0;
            for param in meth.GetParameters do
            begin
              if i = 0 then
                params[i] := aObject
              else
                params[i] := ValueFromMonoObject(aMonoMethInfo.params[i-1], PMonoObject(aMonoParams[i-1]), param.ParamType);
              inc(i);
            end;

            resultValue := meth.Invoke(cls.MetaclassType, params);
            if meth.ReturnType = nil then
              result := nil
            else
              result := ValueToMonoObject(resultValue, aMonoMethInfo.result, meth.ReturnType, lDomain);
            // ripristino parametry by ref

            for i := 0 to aMonoMethInfo.paramCount - 1 do
            begin
              if aMonoMethInfo.params[i].ByRef then
              begin
                aMonoParams[i] := ValueToMonoObject(params[i], aMonoMethInfo.params[i], meth.GetParameters[i].ParamType, lDomain);
              end;
            end;

            exit;
          end;
        end;
      end;
    end;

  end;

end;

class function TMonoDelphiRTTI.IsMonoTypeCompatible(mType: TMonoTypeEnum;
  mByRef: boolean; dType: TRttiType): boolean;

{
(tkUnknown, tkInteger, tkChar, tkEnumeration, tkFloat,
    tkString, tkSet, tkClass, tkMethod, tkWChar, tkLString, tkWString,
    tkVariant, tkArray, tkRecord, tkInterface, tkInt64, tkDynArray, tkUString,
    tkClassRef, tkPointer, tkProcedure);
}
begin
  result := false;

  case mType of
    MONO_TYPE_END: ;
    MONO_TYPE_VOID: result := dType.TypeKind in [tkPointer];
    MONO_TYPE_BOOLEAN: result := dType.TypeKind in [tkInteger, tkEnumeration];
    MONO_TYPE_CHAR: result := dType.TypeKind in [tkChar, tkWChar];
    MONO_TYPE_I1: result := dType.TypeKind in [tkInteger];
    MONO_TYPE_U1: result := dType.TypeKind in [tkInteger];
    MONO_TYPE_I2: result := dType.TypeKind in [tkInteger];
    MONO_TYPE_U2: result := dType.TypeKind in [tkInteger];
    MONO_TYPE_I4: result := dType.TypeKind in [tkInteger, tkInt64];
    MONO_TYPE_U4: result := dType.TypeKind in [tkInteger, tkInt64];
    MONO_TYPE_I8: result := dType.TypeKind in [tkInteger, tkInt64];
    MONO_TYPE_U8: result := dType.TypeKind in [tkInteger, tkInt64];
    MONO_TYPE_R4: result := dType.TypeKind in [tkFloat];
    MONO_TYPE_R8: result := dType.TypeKind in [tkFloat];
    MONO_TYPE_STRING: result := dType.TypeKind in [tkString, tkWString, tkUString];
    MONO_TYPE_PTR: result := dType.TypeKind in [tkPointer];
    MONO_TYPE_BYREF: ;
    MONO_TYPE_VALUETYPE: ;
    MONO_TYPE_CLASS: result := dType.TypeKind in [tkClass];
    MONO_TYPE_VAR: ;
    MONO_TYPE_ARRAY: result := dType.TypeKind in [tkArray, tkDynArray];
    MONO_TYPE_GENERICINST: ;
    MONO_TYPE_TYPEDBYREF: ;
    MONO_TYPE_I: ;
    MONO_TYPE_U: ;
    MONO_TYPE_FNPTR: ;
    MONO_TYPE_OBJECT: result := dType.TypeKind in [tkClass];
    MONO_TYPE_SZARRAY: result := dType.TypeKind in [tkDynArray];
    MONO_TYPE_MVAR: ;
    MONO_TYPE_CMOD_REQD: ;
    MONO_TYPE_CMOD_OPT: ;
    MONO_TYPE_INTERNAL: ;
    MONO_TYPE_MODIFIER: ;
    MONO_TYPE_SENTINEL: ;
    MONO_TYPE_PINNED: ;
    MONO_TYPE_ENUM: ;
  end;
end;


class function TMonoDelphiRTTI.ValueFromMonoObject(mType: TMonoParamDef;
   mValue: PMonoObject; dType: TRttiType): TValue;

  function ExtractClassFromProxy(): TObject;
  var
    lClass, lClassi: PMonoClass;
    lObj: PMonoObject;
    m: PMonoMethod;
    i: integer;
    lsInterface: TList;
  begin
    lClass := MonoJit.FindMonoClass(ExtractNameSpace(mType.ParamTypeName),ExcludeNameSpace(mtype.ParamTypeName));
    m := MonoJit.FindMonoMethod(lClass, 'GetHInstance', '');
    if m = nil then
    begin
      lsInterface := TList.Create;
      MonoJit.GetMonoClassInterfaces(lClass, lsInterface);
      for i := lsInterface.Count - 1 downto 0 do
      begin
        lClassi := PMonoClass(lsInterface[i]);
        //ShowMessage(mono_class_get_name(lClassi));
        m := MonoJit.FindMonoMethod(lClassi, 'GetHInstance', '');
        if m <> nil then
          break;
      end;
      lsInterface.Free;
    end;
    lObj := MonoJit.CallMonoMethodVirt(m, mValue, []);
    i := TMonoConvert.MonoObjToInt(lObj);
    result := TObject(i);
  end;

begin

  case mType.ParamType of
    MONO_TYPE_END: ;
    MONO_TYPE_VOID: ;
    MONO_TYPE_BOOLEAN: Result:=TValue.From<boolean>(TMonoConvert.MonoObjToBoolean(mValue));
    MONO_TYPE_CHAR: ;
    MONO_TYPE_I1: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_U1: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_I2: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_U2: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_I4: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_U4: Result:=TValue.From<Int32>(TMonoConvert.MonoObjToInt(mValue));
    MONO_TYPE_I8: Result:=TValue.From<Int64>(TMonoConvert.MonoObjToInt64(mValue));
    MONO_TYPE_U8: Result:=TValue.From<Int64>(TMonoConvert.MonoObjToInt64(mValue));
    MONO_TYPE_R4: Result:=TValue.From<double>(TMonoConvert.MonoObjToDouble(mValue));
    MONO_TYPE_R8: Result:=TValue.From<double>(TMonoConvert.MonoObjToDouble(mValue));
    MONO_TYPE_STRING: Result:=TValue.From<string>(TMonoConvert.MonoStrToString(PMonoString(mValue)));
    MONO_TYPE_PTR: ;
    MONO_TYPE_BYREF: ;
    MONO_TYPE_VALUETYPE: ;
    MONO_TYPE_CLASS: Result := ExtractClassFromProxy();
    MONO_TYPE_VAR: ;
    MONO_TYPE_ARRAY: ;
    MONO_TYPE_GENERICINST: ;
    MONO_TYPE_TYPEDBYREF: ;
    MONO_TYPE_I: ;
    MONO_TYPE_U: ;
    MONO_TYPE_FNPTR: ;
    MONO_TYPE_OBJECT: ;
    MONO_TYPE_SZARRAY: begin
        if dType is TRttiDynamicArrayType then
        begin
          TMonoConvert.MonoArrayToDynArray(PMonoArray(mValue), mType.monoType, result, dType.Handle);
        end;
      end;
    MONO_TYPE_MVAR: ;
    MONO_TYPE_CMOD_REQD: ;
    MONO_TYPE_CMOD_OPT: ;
    MONO_TYPE_INTERNAL: ;
    MONO_TYPE_MODIFIER: ;
    MONO_TYPE_SENTINEL: ;
    MONO_TYPE_PINNED: ;
    MONO_TYPE_ENUM: ;
  end;
end;

class function TMonoDelphiRTTI.ValueToMonoObject(aValue: TValue;
  mType: TMonoParamDef; dType: TRttiType; aDomain: PMonoDomain = nil): PMonoObject;
begin
  if aDomain = nil then
    aDomain := mono_domain_get();
  result := nil;
  // in caso di oggetti utilizzare il proxy
  case mtype.ParamType of
    MONO_TYPE_END: ;
    MONO_TYPE_VOID: ;
    MONO_TYPE_BOOLEAN: result := TMonoConvert.BooleanToMonoObj(aValue.AsType<boolean>, aDomain);
    MONO_TYPE_CHAR: ;
    MONO_TYPE_I1: result := TMonoConvert.SmallIntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_U1: result := TMonoConvert.SmallIntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_I2: result := TMonoConvert.SmallIntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_U2: result := TMonoConvert.SmallIntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_I4: result := TMonoConvert.IntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_U4: result := TMonoConvert.IntToMonoObj(aValue.AsInteger, aDomain);
    MONO_TYPE_I8: result := TMonoConvert.Int64ToMonoObj(aValue.AsInt64, aDomain);
    MONO_TYPE_U8: result := TMonoConvert.Int64ToMonoObj(aValue.AsInt64, aDomain);
    MONO_TYPE_R4: result := TMonoConvert.DoubleToMonoObj(aValue.AsType<double>, aDomain);
    MONO_TYPE_R8: result := TMonoConvert.DoubleToMonoObj(aValue.AsType<double>, aDomain);
    MONO_TYPE_STRING: result := PMonoObject(TMonoConvert.StringToMonoStr(aValue.AsString, aDomain));
    MONO_TYPE_PTR: ;
    MONO_TYPE_BYREF: ;
    MONO_TYPE_VALUETYPE: ;
    MONO_TYPE_CLASS: result := MonoJit.CreateMonoProxy(aValue.AsObject, mType.ParamTypeName, aDomain);  //CreateMonoProxy;// todo: result object to interface/proxy
    MONO_TYPE_VAR: ;
    MONO_TYPE_ARRAY: ;
    MONO_TYPE_GENERICINST: ;
    MONO_TYPE_TYPEDBYREF: ;
    MONO_TYPE_I: ;
    MONO_TYPE_U: ;
    MONO_TYPE_FNPTR: ;
    MONO_TYPE_OBJECT: ;
    MONO_TYPE_SZARRAY: begin
        if aValue.IsArray then
        begin
          result := PMonoObject(TMonoConvert.DynArrayToMonoArray(mType.monoType, aValue, dType.Handle, aDomain));
        end;
      end;
    MONO_TYPE_MVAR: ;
    MONO_TYPE_CMOD_REQD: ;
    MONO_TYPE_CMOD_OPT: ;
    MONO_TYPE_INTERNAL: ;
    MONO_TYPE_MODIFIER: ;
    MONO_TYPE_SENTINEL: ;
    MONO_TYPE_PINNED: ;
    MONO_TYPE_ENUM: ;
  end;
end;



end.
